home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / generic / tkTest.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  31.8 KB  |  1,135 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tkTest.c --
  3.  *
  4.  *    This file contains C command procedures for a bunch of additional
  5.  *    Tcl commands that are used for testing out Tcl's C interfaces.
  6.  *    These commands are not normally included in Tcl applications;
  7.  *    they're only used for testing.
  8.  *
  9.  * Copyright (c) 1993-1994 The Regents of the University of California.
  10.  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  11.  *
  12.  * See the file "license.terms" for information on usage and redistribution
  13.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  *
  15.  * SCCS: @(#) tkTest.c 1.47 97/05/08 11:22:20
  16.  */
  17.  
  18. #include "tkInt.h"
  19. #include "tkPort.h"    
  20.  
  21. #ifdef __WIN32__
  22. #include "tkWinInt.h"
  23. #endif
  24.  
  25. #ifdef MAC_TCL
  26. #include "tkScrollbar.h"
  27. #endif
  28.  
  29. #ifdef __UNIX__
  30. #include "tkUnixInt.h"
  31. #endif
  32.  
  33. /*
  34.  * The following data structure represents the master for a test
  35.  * image:
  36.  */
  37.  
  38. typedef struct TImageMaster {
  39.     Tk_ImageMaster master;    /* Tk's token for image master. */
  40.     Tcl_Interp *interp;        /* Interpreter for application. */
  41.     int width, height;        /* Dimensions of image. */
  42.     char *imageName;        /* Name of image (malloc-ed). */
  43.     char *varName;        /* Name of variable in which to log
  44.                  * events for image (malloc-ed). */
  45. } TImageMaster;
  46.  
  47. /*
  48.  * The following data structure represents a particular use of a
  49.  * particular test image.
  50.  */
  51.  
  52. typedef struct TImageInstance {
  53.     TImageMaster *masterPtr;    /* Pointer to master for image. */
  54.     XColor *fg;            /* Foreground color for drawing in image. */
  55.     GC gc;            /* Graphics context for drawing in image. */
  56. } TImageInstance;
  57.  
  58. /*
  59.  * The type record for test images:
  60.  */
  61.  
  62. static int        ImageCreate _ANSI_ARGS_((Tcl_Interp *interp,
  63.                 char *name, int argc, char **argv,
  64.                 Tk_ImageType *typePtr, Tk_ImageMaster master,
  65.                 ClientData *clientDataPtr));
  66. static ClientData    ImageGet _ANSI_ARGS_((Tk_Window tkwin,
  67.                 ClientData clientData));
  68. static void        ImageDisplay _ANSI_ARGS_((ClientData clientData,
  69.                 Display *display, Drawable drawable, 
  70.                 int imageX, int imageY, int width,
  71.                 int height, int drawableX,
  72.                 int drawableY));
  73. static void        ImageFree _ANSI_ARGS_((ClientData clientData,
  74.                 Display *display));
  75. static void        ImageDelete _ANSI_ARGS_((ClientData clientData));
  76.  
  77. static Tk_ImageType imageType = {
  78.     "test",            /* name */
  79.     ImageCreate,        /* createProc */
  80.     ImageGet,            /* getProc */
  81.     ImageDisplay,        /* displayProc */
  82.     ImageFree,            /* freeProc */
  83.     ImageDelete,        /* deleteProc */
  84.     (Tk_ImageType *) NULL    /* nextPtr */
  85. };
  86.  
  87. /*
  88.  * One of the following structures describes each of the interpreters
  89.  * created by the "testnewapp" command.  This information is used by
  90.  * the "testdeleteinterps" command to destroy all of those interpreters.
  91.  */
  92.  
  93. typedef struct NewApp {
  94.     Tcl_Interp *interp;        /* Token for interpreter. */
  95.     struct NewApp *nextPtr;    /* Next in list of new interpreters. */
  96. } NewApp;
  97.  
  98. static NewApp *newAppPtr = NULL;
  99.                 /* First in list of all new interpreters. */
  100.  
  101. /*
  102.  * Declaration for the square widget's class command procedure:
  103.  */
  104.  
  105. extern int SquareCmd _ANSI_ARGS_((ClientData clientData,
  106.     Tcl_Interp *interp, int argc, char *argv[]));
  107.  
  108. typedef struct CBinding {
  109.     Tcl_Interp *interp;
  110.     char *command;
  111.     char *delete;
  112. } CBinding;
  113.  
  114. /*
  115.  * Forward declarations for procedures defined later in this file:
  116.  */
  117.  
  118. static int        CBindingEvalProc _ANSI_ARGS_((ClientData clientData, 
  119.                 Tcl_Interp *interp, XEvent *eventPtr,
  120.                 Tk_Window tkwin, KeySym keySym));
  121. static void        CBindingFreeProc _ANSI_ARGS_((ClientData clientData));
  122. int            Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp));
  123. static int        ImageCmd _ANSI_ARGS_((ClientData dummy,
  124.                 Tcl_Interp *interp, int argc, char **argv));
  125. static int        TestcbindCmd _ANSI_ARGS_((ClientData dummy,
  126.                 Tcl_Interp *interp, int argc, char **argv));
  127. #ifdef __WIN32__
  128. static int        TestclipboardCmd _ANSI_ARGS_((ClientData dummy,
  129.                 Tcl_Interp *interp, int argc, char **argv));
  130. #endif
  131. static int        TestdeleteappsCmd _ANSI_ARGS_((ClientData dummy,
  132.                 Tcl_Interp *interp, int argc, char **argv));
  133. static int        TestmakeexistCmd _ANSI_ARGS_((ClientData dummy,
  134.                 Tcl_Interp *interp, int argc, char **argv));
  135. static int        TestmenubarCmd _ANSI_ARGS_((ClientData dummy,
  136.                 Tcl_Interp *interp, int argc, char **argv));
  137. #if defined(__WIN32__) || defined(MAC_TCL)
  138. static int        TestmetricsCmd _ANSI_ARGS_((ClientData dummy,
  139.                 Tcl_Interp *interp, int argc, char **argv));
  140. #endif
  141. static int        TestsendCmd _ANSI_ARGS_((ClientData dummy,
  142.                 Tcl_Interp *interp, int argc, char **argv));
  143. static int        TestpropCmd _ANSI_ARGS_((ClientData dummy,
  144.                 Tcl_Interp *interp, int argc, char **argv));
  145. #if !(defined(__WIN32__) || defined(MAC_TCL))
  146. static int        TestwrapperCmd _ANSI_ARGS_((ClientData dummy,
  147.                 Tcl_Interp *interp, int argc, char **argv));
  148. #endif
  149.  
  150. /*
  151.  * External (platform specific) initialization routine:
  152.  */
  153.  
  154. EXTERN int        TkplatformtestInit _ANSI_ARGS_((
  155.                 Tcl_Interp *interp));
  156. #ifndef MAC_TCL
  157. #define TkplatformtestInit(x) TCL_OK
  158. #endif
  159.  
  160. /*
  161.  *----------------------------------------------------------------------
  162.  *
  163.  * Tktest_Init --
  164.  *
  165.  *    This procedure performs intialization for the Tk test
  166.  *    suite exensions.
  167.  *
  168.  * Results:
  169.  *    Returns a standard Tcl completion code, and leaves an error
  170.  *    message in interp->result if an error occurs.
  171.  *
  172.  * Side effects:
  173.  *    Creates several test commands.
  174.  *
  175.  *----------------------------------------------------------------------
  176.  */
  177.  
  178. int
  179. Tktest_Init(interp)
  180.     Tcl_Interp *interp;        /* Interpreter for application. */
  181. {
  182.     static int initialized = 0;
  183.  
  184.     /*
  185.      * Create additional commands for testing Tk.
  186.      */
  187.  
  188.     if (Tcl_PkgProvide(interp, "Tktest", TK_VERSION) == TCL_ERROR) {
  189.         return TCL_ERROR;
  190.     }
  191.  
  192.     Tcl_CreateCommand(interp, "square", SquareCmd,
  193.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  194. #ifdef __WIN32__
  195.     Tcl_CreateCommand(interp, "testclipboard", TestclipboardCmd,
  196.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  197. #endif
  198.     Tcl_CreateCommand(interp, "testcbind", TestcbindCmd,
  199.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  200.     Tcl_CreateCommand(interp, "testdeleteapps", TestdeleteappsCmd,
  201.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  202.     Tcl_CreateCommand(interp, "testembed", TkpTestembedCmd,
  203.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  204.     Tcl_CreateCommand(interp, "testmakeexist", TestmakeexistCmd,
  205.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  206.     Tcl_CreateCommand(interp, "testmenubar", TestmenubarCmd,
  207.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  208. #if defined(__WIN32__) || defined(MAC_TCL)
  209.     Tcl_CreateCommand(interp, "testmetrics", TestmetricsCmd,
  210.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  211. #endif
  212.     Tcl_CreateCommand(interp, "testprop", TestpropCmd,
  213.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  214.     Tcl_CreateCommand(interp, "testsend", TestsendCmd,
  215.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  216. #if !(defined(__WIN32__) || defined(MAC_TCL))
  217.     Tcl_CreateCommand(interp, "testwrapper", TestwrapperCmd,
  218.         (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL);
  219. #endif
  220.  
  221. /*
  222.      * Create test image type.
  223.      */
  224.  
  225.     if (!initialized) {
  226.     initialized = 1;
  227.     Tk_CreateImageType(&imageType);
  228.     }
  229.  
  230.     /*
  231.      * And finally add any platform specific test commands.
  232.      */
  233.     
  234.     return TkplatformtestInit(interp);
  235. }
  236.  
  237. /*
  238.  *----------------------------------------------------------------------
  239.  *
  240.  * TestclipboardCmd --
  241.  *
  242.  *    This procedure implements the testclipboard command. It provides
  243.  *    a way to determine the actual contents of the Windows clipboard.
  244.  *
  245.  * Results:
  246.  *    A standard Tcl result.
  247.  *
  248.  * Side effects:
  249.  *    None.
  250.  *
  251.  *----------------------------------------------------------------------
  252.  */
  253.  
  254. #ifdef __WIN32__
  255. static int
  256. TestclipboardCmd(clientData, interp, argc, argv)
  257.     ClientData clientData;        /* Main window for application. */
  258.     Tcl_Interp *interp;            /* Current interpreter. */
  259.     int argc;                /* Number of arguments. */
  260.     char **argv;            /* Argument strings. */
  261. {
  262.     TkWindow *winPtr = (TkWindow *) clientData;
  263.     HGLOBAL handle;
  264.     char *data;
  265.  
  266.     if (OpenClipboard(NULL)) {
  267.     handle = GetClipboardData(CF_TEXT);
  268.     if (handle != NULL) {
  269.         data = GlobalLock(handle);
  270.         Tcl_AppendResult(interp, data, (char *) NULL);
  271.         GlobalUnlock(handle);
  272.     }
  273.     CloseClipboard();
  274.     }
  275.     return TCL_OK;
  276. }
  277. #endif
  278.  
  279. /*
  280.  *----------------------------------------------------------------------
  281.  *
  282.  * TestcbindCmd --
  283.  *
  284.  *    This procedure implements the "testcbinding" command.  It provides
  285.  *    a set of functions for testing C bindings in tkBind.c.
  286.  *
  287.  * Results:
  288.  *    A standard Tcl result.
  289.  *
  290.  * Side effects:
  291.  *    Depends on option;  see below.
  292.  *
  293.  *----------------------------------------------------------------------
  294.  */
  295.  
  296. static int
  297. TestcbindCmd(clientData, interp, argc, argv)
  298.     ClientData clientData;        /* Main window for application. */
  299.     Tcl_Interp *interp;            /* Current interpreter. */
  300.     int argc;                /* Number of arguments. */
  301.     char **argv;            /* Argument strings. */
  302. {
  303.     TkWindow *winPtr;
  304.     Tk_Window tkwin;
  305.     ClientData object;
  306.     CBinding *cbindPtr;
  307.     
  308.     
  309.     if (argc < 4 || argc > 5) {
  310.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  311.         " bindtag pattern command ?deletecommand?", (char *) NULL);
  312.     return TCL_ERROR;
  313.     }
  314.  
  315.     tkwin = (Tk_Window) clientData;
  316.  
  317.     if (argv[1][0] == '.') {
  318.     winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin);
  319.     if (winPtr == NULL) {
  320.         return TCL_ERROR;
  321.     }
  322.     object = (ClientData) winPtr->pathName;
  323.     } else {
  324.     winPtr = (TkWindow *) clientData;
  325.     object = (ClientData) Tk_GetUid(argv[1]);
  326.     }
  327.  
  328.     if (argv[3][0] == '\0') {
  329.     return Tk_DeleteBinding(interp, winPtr->mainPtr->bindingTable,
  330.         object, argv[2]);
  331.     }
  332.  
  333.     cbindPtr = (CBinding *) ckalloc(sizeof(CBinding));
  334.     cbindPtr->interp = interp;
  335.     cbindPtr->command =
  336.         strcpy((char *) ckalloc(strlen(argv[3]) + 1), argv[3]);
  337.     if (argc == 4) {
  338.     cbindPtr->delete = NULL;
  339.     } else {
  340.     cbindPtr->delete =
  341.         strcpy((char *) ckalloc(strlen(argv[4]) + 1), argv[4]);
  342.     }
  343.  
  344.     if (TkCreateBindingProcedure(interp, winPtr->mainPtr->bindingTable,
  345.         object, argv[2], CBindingEvalProc, CBindingFreeProc,
  346.         (ClientData) cbindPtr) == 0) {
  347.     ckfree((char *) cbindPtr->command);
  348.     if (cbindPtr->delete != NULL) {
  349.         ckfree((char *) cbindPtr->delete);
  350.     }
  351.     ckfree((char *) cbindPtr);
  352.     return TCL_ERROR;
  353.     }
  354.     return TCL_OK;
  355. }
  356.  
  357. static int
  358. CBindingEvalProc(clientData, interp, eventPtr, tkwin, keySym)
  359.     ClientData clientData;
  360.     Tcl_Interp *interp;
  361.     XEvent *eventPtr;
  362.     Tk_Window tkwin;
  363.     KeySym keySym;
  364. {
  365.     CBinding *cbindPtr;
  366.  
  367.     cbindPtr = (CBinding *) clientData;
  368.     
  369.     return Tcl_GlobalEval(interp, cbindPtr->command);
  370. }
  371.  
  372. static void
  373. CBindingFreeProc(clientData)
  374.     ClientData clientData;
  375. {
  376.     CBinding *cbindPtr = (CBinding *) clientData;
  377.     
  378.     if (cbindPtr->delete != NULL) {
  379.     Tcl_GlobalEval(cbindPtr->interp, cbindPtr->delete);
  380.     ckfree((char *) cbindPtr->delete);
  381.     }
  382.     ckfree((char *) cbindPtr->command);
  383.     ckfree((char *) cbindPtr);
  384. }
  385.  
  386. /*
  387.  *----------------------------------------------------------------------
  388.  *
  389.  * TestdeleteappsCmd --
  390.  *
  391.  *    This procedure implements the "testdeleteapps" command.  It cleans
  392.  *    up all the interpreters left behind by the "testnewapp" command.
  393.  *
  394.  * Results:
  395.  *    A standard Tcl result.
  396.  *
  397.  * Side effects:
  398.  *    All the intepreters created by previous calls to "testnewapp"
  399.  *    get deleted.
  400.  *
  401.  *----------------------------------------------------------------------
  402.  */
  403.  
  404.     /* ARGSUSED */
  405. static int
  406. TestdeleteappsCmd(clientData, interp, argc, argv)
  407.     ClientData clientData;        /* Main window for application. */
  408.     Tcl_Interp *interp;            /* Current interpreter. */
  409.     int argc;                /* Number of arguments. */
  410.     char **argv;            /* Argument strings. */
  411. {
  412.     NewApp *nextPtr;
  413.  
  414.     while (newAppPtr != NULL) {
  415.     nextPtr = newAppPtr->nextPtr;
  416.     Tcl_DeleteInterp(newAppPtr->interp);
  417.     ckfree((char *) newAppPtr);
  418.     newAppPtr = nextPtr;
  419.     }
  420.  
  421.     return TCL_OK;
  422. }
  423.  
  424. /*
  425.  *----------------------------------------------------------------------
  426.  *
  427.  * ImageCreate --
  428.  *
  429.  *    This procedure is called by the Tk image code to create "test"
  430.  *    images.
  431.  *
  432.  * Results:
  433.  *    A standard Tcl result.
  434.  *
  435.  * Side effects:
  436.  *    The data structure for a new image is allocated.
  437.  *
  438.  *----------------------------------------------------------------------
  439.  */
  440.  
  441.     /* ARGSUSED */
  442. static int
  443. ImageCreate(interp, name, argc, argv, typePtr, master, clientDataPtr)
  444.     Tcl_Interp *interp;        /* Interpreter for application containing
  445.                  * image. */
  446.     char *name;            /* Name to use for image. */
  447.     int argc;            /* Number of arguments. */
  448.     char **argv;        /* Argument strings for options (doesn't
  449.                  * include image name or type). */
  450.     Tk_ImageType *typePtr;    /* Pointer to our type record (not used). */
  451.     Tk_ImageMaster master;    /* Token for image, to be used by us in
  452.                  * later callbacks. */
  453.     ClientData *clientDataPtr;    /* Store manager's token for image here;
  454.                  * it will be returned in later callbacks. */
  455. {
  456.     TImageMaster *timPtr;
  457.     char *varName;
  458.     int i;
  459.  
  460.     varName = "log";
  461.     for (i = 0; i < argc; i += 2) {
  462.     if (strcmp(argv[i], "-variable") != 0) {
  463.         Tcl_AppendResult(interp, "bad option name \"", argv[i],
  464.             "\"", (char *) NULL);
  465.         return TCL_ERROR;
  466.     }
  467.     if ((i+1) == argc) {
  468.         Tcl_AppendResult(interp, "no value given for \"", argv[i],
  469.             "\" option", (char *) NULL);
  470.         return TCL_ERROR;
  471.     }
  472.     varName = argv[i+1];
  473.     }
  474.     timPtr = (TImageMaster *) ckalloc(sizeof(TImageMaster));
  475.     timPtr->master = master;
  476.     timPtr->interp = interp;
  477.     timPtr->width = 30;
  478.     timPtr->height = 15;
  479.     timPtr->imageName = (char *) ckalloc((unsigned) (strlen(name) + 1));
  480.     strcpy(timPtr->imageName, name);
  481.     timPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1));
  482.     strcpy(timPtr->varName, varName);
  483.     Tcl_CreateCommand(interp, name, ImageCmd, (ClientData) timPtr,
  484.         (Tcl_CmdDeleteProc *) NULL);
  485.     *clientDataPtr = (ClientData) timPtr;
  486.     Tk_ImageChanged(master, 0, 0, 30, 15, 30, 15);
  487.     return TCL_OK;
  488. }
  489.  
  490. /*
  491.  *----------------------------------------------------------------------
  492.  *
  493.  * ImageCmd --
  494.  *
  495.  *    This procedure implements the commands corresponding to individual
  496.  *    images. 
  497.  *
  498.  * Results:
  499.  *    A standard Tcl result.
  500.  *
  501.  * Side effects:
  502.  *    Forces windows to be created.
  503.  *
  504.  *----------------------------------------------------------------------
  505.  */
  506.  
  507.     /* ARGSUSED */
  508. static int
  509. ImageCmd(clientData, interp, argc, argv)
  510.     ClientData clientData;        /* Main window for application. */
  511.     Tcl_Interp *interp;            /* Current interpreter. */
  512.     int argc;                /* Number of arguments. */
  513.     char **argv;            /* Argument strings. */
  514. {
  515.     TImageMaster *timPtr = (TImageMaster *) clientData;
  516.     int x, y, width, height;
  517.  
  518.     if (argc < 2) {
  519.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  520.         argv[0], "option ?arg arg ...?", (char *) NULL);
  521.     return TCL_ERROR;
  522.     }
  523.     if (strcmp(argv[1], "changed") == 0) {
  524.     if (argc != 8) {
  525.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  526.             argv[0], " changed x y width height imageWidth imageHeight",
  527.             (char *) NULL);
  528.         return TCL_ERROR;
  529.     }
  530.     if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK)
  531.         || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)
  532.         || (Tcl_GetInt(interp, argv[4], &width) != TCL_OK)
  533.         || (Tcl_GetInt(interp, argv[5], &height) != TCL_OK)
  534.         || (Tcl_GetInt(interp, argv[6], &timPtr->width) != TCL_OK)
  535.         || (Tcl_GetInt(interp, argv[7], &timPtr->height) != TCL_OK)) {
  536.         return TCL_ERROR;
  537.     }
  538.     Tk_ImageChanged(timPtr->master, x, y, width, height, timPtr->width,
  539.         timPtr->height);
  540.     } else {
  541.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  542.         "\": must be changed", (char *) NULL);
  543.     return TCL_ERROR;
  544.     }
  545.     return TCL_OK;
  546. }
  547.  
  548. /*
  549.  *----------------------------------------------------------------------
  550.  *
  551.  * ImageGet --
  552.  *
  553.  *    This procedure is called by Tk to set things up for using a
  554.  *    test image in a particular widget.
  555.  *
  556.  * Results:
  557.  *    The return value is a token for the image instance, which is
  558.  *    used in future callbacks to ImageDisplay and ImageFree.
  559.  *
  560.  * Side effects:
  561.  *    None.
  562.  *
  563.  *----------------------------------------------------------------------
  564.  */
  565.  
  566. static ClientData
  567. ImageGet(tkwin, clientData)
  568.     Tk_Window tkwin;        /* Token for window in which image will
  569.                  * be used. */
  570.     ClientData clientData;    /* Pointer to TImageMaster for image. */
  571. {
  572.     TImageMaster *timPtr = (TImageMaster *) clientData;
  573.     TImageInstance *instPtr;
  574.     char buffer[100];
  575.     XGCValues gcValues;
  576.  
  577.     sprintf(buffer, "%s get", timPtr->imageName);
  578.     Tcl_SetVar(timPtr->interp, timPtr->varName, buffer,
  579.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  580.  
  581.     instPtr = (TImageInstance *) ckalloc(sizeof(TImageInstance));
  582.     instPtr->masterPtr = timPtr;
  583.     instPtr->fg = Tk_GetColor(timPtr->interp, tkwin, "#ff0000");
  584.     gcValues.foreground = instPtr->fg->pixel;
  585.     instPtr->gc = Tk_GetGC(tkwin, GCForeground, &gcValues);
  586.     return (ClientData) instPtr;
  587. }
  588.  
  589. /*
  590.  *----------------------------------------------------------------------
  591.  *
  592.  * ImageDisplay --
  593.  *
  594.  *    This procedure is invoked to redisplay part or all of an
  595.  *    image in a given drawable.
  596.  *
  597.  * Results:
  598.  *    None.
  599.  *
  600.  * Side effects:
  601.  *    The image gets partially redrawn, as an "X" that shows the
  602.  *    exact redraw area.
  603.  *
  604.  *----------------------------------------------------------------------
  605.  */
  606.  
  607. static void
  608. ImageDisplay(clientData, display, drawable, imageX, imageY, width, height,
  609.     drawableX, drawableY)
  610.     ClientData clientData;    /* Pointer to TImageInstance for image. */
  611.     Display *display;        /* Display to use for drawing. */
  612.     Drawable drawable;        /* Where to redraw image. */
  613.     int imageX, imageY;        /* Origin of area to redraw, relative to
  614.                  * origin of image. */
  615.     int width, height;        /* Dimensions of area to redraw. */
  616.     int drawableX, drawableY;    /* Coordinates in drawable corresponding to
  617.                  * imageX and imageY. */
  618. {
  619.     TImageInstance *instPtr = (TImageInstance *) clientData;
  620.     char buffer[200];
  621.  
  622.     sprintf(buffer, "%s display %d %d %d %d %d %d",
  623.         instPtr->masterPtr->imageName, imageX, imageY, width, height,
  624.         drawableX, drawableY);
  625.     Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer,
  626.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  627.     if (width > (instPtr->masterPtr->width - imageX)) {
  628.     width = instPtr->masterPtr->width - imageX;
  629.     }
  630.     if (height > (instPtr->masterPtr->height - imageY)) {
  631.     height = instPtr->masterPtr->height - imageY;
  632.     }
  633.     XDrawRectangle(display, drawable, instPtr->gc, drawableX, drawableY,
  634.         (unsigned) (width-1), (unsigned) (height-1));
  635.     XDrawLine(display, drawable, instPtr->gc, drawableX, drawableY,
  636.         (int) (drawableX + width - 1), (int) (drawableY + height - 1));
  637.     XDrawLine(display, drawable, instPtr->gc, drawableX,
  638.         (int) (drawableY + height - 1),
  639.         (int) (drawableX + width - 1), drawableY);
  640. }
  641.  
  642. /*
  643.  *----------------------------------------------------------------------
  644.  *
  645.  * ImageFree --
  646.  *
  647.  *    This procedure is called when an instance of an image is
  648.  *     no longer used.
  649.  *
  650.  * Results:
  651.  *    None.
  652.  *
  653.  * Side effects:
  654.  *    Information related to the instance is freed.
  655.  *
  656.  *----------------------------------------------------------------------
  657.  */
  658.  
  659. static void
  660. ImageFree(clientData, display)
  661.     ClientData clientData;    /* Pointer to TImageInstance for instance. */
  662.     Display *display;        /* Display where image was to be drawn. */
  663. {
  664.     TImageInstance *instPtr = (TImageInstance *) clientData;
  665.     char buffer[200];
  666.  
  667.     sprintf(buffer, "%s free", instPtr->masterPtr->imageName);
  668.     Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer,
  669.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  670.     Tk_FreeColor(instPtr->fg);
  671.     Tk_FreeGC(display, instPtr->gc);
  672.     ckfree((char *) instPtr);
  673. }
  674.  
  675. /*
  676.  *----------------------------------------------------------------------
  677.  *
  678.  * ImageDelete --
  679.  *
  680.  *    This procedure is called to clean up a test image when
  681.  *    an application goes away.
  682.  *
  683.  * Results:
  684.  *    None.
  685.  *
  686.  * Side effects:
  687.  *    Information about the image is deleted.
  688.  *
  689.  *----------------------------------------------------------------------
  690.  */
  691.  
  692. static void
  693. ImageDelete(clientData)
  694.     ClientData clientData;    /* Pointer to TImageMaster for image.  When
  695.                  * this procedure is called, no more
  696.                  * instances exist. */
  697. {
  698.     TImageMaster *timPtr = (TImageMaster *) clientData;
  699.     char buffer[100];
  700.  
  701.     sprintf(buffer, "%s delete", timPtr->imageName);
  702.     Tcl_SetVar(timPtr->interp, timPtr->varName, buffer,
  703.         TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
  704.  
  705.     Tcl_DeleteCommand(timPtr->interp, timPtr->imageName);
  706.     ckfree(timPtr->imageName);
  707.     ckfree(timPtr->varName);
  708.     ckfree((char *) timPtr);
  709. }
  710.  
  711. /*
  712.  *----------------------------------------------------------------------
  713.  *
  714.  * TestmakeexistCmd --
  715.  *
  716.  *    This procedure implements the "testmakeexist" command.  It calls
  717.  *    Tk_MakeWindowExist on each of its arguments to force the windows
  718.  *    to be created.
  719.  *
  720.  * Results:
  721.  *    A standard Tcl result.
  722.  *
  723.  * Side effects:
  724.  *    Forces windows to be created.
  725.  *
  726.  *----------------------------------------------------------------------
  727.  */
  728.  
  729.     /* ARGSUSED */
  730. static int
  731. TestmakeexistCmd(clientData, interp, argc, argv)
  732.     ClientData clientData;        /* Main window for application. */
  733.     Tcl_Interp *interp;            /* Current interpreter. */
  734.     int argc;                /* Number of arguments. */
  735.     char **argv;            /* Argument strings. */
  736. {
  737.     Tk_Window main = (Tk_Window) clientData;
  738.     int i;
  739.     Tk_Window tkwin;
  740.  
  741.     for (i = 1; i < argc; i++) {
  742.     tkwin = Tk_NameToWindow(interp, argv[i], main);
  743.     if (tkwin == NULL) {
  744.         return TCL_ERROR;
  745.     }
  746.     Tk_MakeWindowExist(tkwin);
  747.     }
  748.  
  749.     return TCL_OK;
  750. }
  751.  
  752. /*
  753.  *----------------------------------------------------------------------
  754.  *
  755.  * TestmenubarCmd --
  756.  *
  757.  *    This procedure implements the "testmenubar" command.  It is used
  758.  *    to test the Unix facilities for creating space above a toplevel
  759.  *    window for a menubar.
  760.  *
  761.  * Results:
  762.  *    A standard Tcl result.
  763.  *
  764.  * Side effects:
  765.  *    Changes menubar related stuff.
  766.  *
  767.  *----------------------------------------------------------------------
  768.  */
  769.  
  770.     /* ARGSUSED */
  771. static int
  772. TestmenubarCmd(clientData, interp, argc, argv)
  773.     ClientData clientData;        /* Main window for application. */
  774.     Tcl_Interp *interp;            /* Current interpreter. */
  775.     int argc;                /* Number of arguments. */
  776.     char **argv;            /* Argument strings. */
  777. {
  778. #ifdef __UNIX__
  779.     Tk_Window main = (Tk_Window) clientData;
  780.     Tk_Window tkwin, menubar;
  781.  
  782.     if (argc < 2) {
  783.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  784.         " option ?arg ...?\"", (char *) NULL);
  785.     return TCL_ERROR;
  786.     }
  787.  
  788.     if (strcmp(argv[1], "window") == 0) {
  789.     if (argc != 4) {
  790.         Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  791.             "window toplevel menubar\"", (char *) NULL);
  792.         return TCL_ERROR;
  793.     }
  794.     tkwin = Tk_NameToWindow(interp, argv[2], main);
  795.     if (tkwin == NULL) {
  796.         return TCL_ERROR;
  797.     }
  798.     if (argv[3][0] == 0) {
  799.         TkUnixSetMenubar(tkwin, NULL);
  800.     } else {
  801.         menubar = Tk_NameToWindow(interp, argv[3], main);
  802.         if (menubar == NULL) {
  803.         return TCL_ERROR;
  804.         }
  805.         TkUnixSetMenubar(tkwin, menubar);
  806.     }
  807.     } else {
  808.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  809.         "\": must be  window", (char *) NULL);
  810.     return TCL_ERROR;
  811.     }
  812.  
  813.     return TCL_OK;
  814. #else
  815.     interp->result = "testmenubar is supported only under Unix";
  816.     return TCL_ERROR;
  817. #endif
  818. }
  819.  
  820. /*
  821.  *----------------------------------------------------------------------
  822.  *
  823.  * TestmetricsCmd --
  824.  *
  825.  *    This procedure implements the testmetrics command. It provides
  826.  *    a way to determine the size of various widget components.
  827.  *
  828.  * Results:
  829.  *    A standard Tcl result.
  830.  *
  831.  * Side effects:
  832.  *    None.
  833.  *
  834.  *----------------------------------------------------------------------
  835.  */
  836.  
  837. #ifdef __WIN32__
  838. static int
  839. TestmetricsCmd(clientData, interp, argc, argv)
  840.     ClientData clientData;        /* Main window for application. */
  841.     Tcl_Interp *interp;            /* Current interpreter. */
  842.     int argc;                /* Number of arguments. */
  843.     char **argv;            /* Argument strings. */
  844. {
  845.     char buf[200];
  846.  
  847.     if (argc < 2) {
  848.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  849.         " option ?arg ...?\"", (char *) NULL);
  850.     return TCL_ERROR;
  851.     }
  852.  
  853.     if (strcmp(argv[1], "cyvscroll") == 0) {
  854.     sprintf(buf, "%d", GetSystemMetrics(SM_CYVSCROLL));
  855.     Tcl_AppendResult(interp, buf, (char *) NULL);
  856.     } else  if (strcmp(argv[1], "cxhscroll") == 0) {
  857.     sprintf(buf, "%d", GetSystemMetrics(SM_CXHSCROLL));
  858.     Tcl_AppendResult(interp, buf, (char *) NULL);
  859.     } else {
  860.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  861.         "\": must be cxhscroll or cyvscroll", (char *) NULL);
  862.     return TCL_ERROR;
  863.     }
  864.     return TCL_OK;
  865. }
  866. #endif
  867. #ifdef MAC_TCL
  868. static int
  869. TestmetricsCmd(clientData, interp, argc, argv)
  870.     ClientData clientData;        /* Main window for application. */
  871.     Tcl_Interp *interp;            /* Current interpreter. */
  872.     int argc;                /* Number of arguments. */
  873.     char **argv;            /* Argument strings. */
  874. {
  875.     Tk_Window tkwin = (Tk_Window) clientData;
  876.     TkWindow *winPtr;
  877.     char buf[200];
  878.  
  879.     if (argc != 3) {
  880.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  881.         " option window\"", (char *) NULL);
  882.     return TCL_ERROR;
  883.     }
  884.  
  885.     winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin);
  886.     if (winPtr == NULL) {
  887.     return TCL_ERROR;
  888.     }
  889.     
  890.     if (strcmp(argv[1], "cyvscroll") == 0) {
  891.     sprintf(buf, "%d", ((TkScrollbar *) winPtr->instanceData)->width);
  892.     Tcl_AppendResult(interp, buf, (char *) NULL);
  893.     } else  if (strcmp(argv[1], "cxhscroll") == 0) {
  894.     sprintf(buf, "%d", ((TkScrollbar *) winPtr->instanceData)->width);
  895.     Tcl_AppendResult(interp, buf, (char *) NULL);
  896.     } else {
  897.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  898.         "\": must be cxhscroll or cyvscroll", (char *) NULL);
  899.     return TCL_ERROR;
  900.     }
  901.     return TCL_OK;
  902. }
  903. #endif
  904.  
  905. /*
  906.  *----------------------------------------------------------------------
  907.  *
  908.  * TestpropCmd --
  909.  *
  910.  *    This procedure implements the "testprop" command.  It fetches
  911.  *    and prints the value of a property on a window.
  912.  *
  913.  * Results:
  914.  *    A standard Tcl result.
  915.  *
  916.  * Side effects:
  917.  *    None.
  918.  *
  919.  *----------------------------------------------------------------------
  920.  */
  921.  
  922.     /* ARGSUSED */
  923. static int
  924. TestpropCmd(clientData, interp, argc, argv)
  925.     ClientData clientData;        /* Main window for application. */
  926.     Tcl_Interp *interp;            /* Current interpreter. */
  927.     int argc;                /* Number of arguments. */
  928.     char **argv;            /* Argument strings. */
  929. {
  930.     Tk_Window main = (Tk_Window) clientData;
  931.     int result, actualFormat, length, value;
  932.     unsigned long bytesAfter;
  933.     Atom actualType, propName;
  934.     char *property, *p, *end;
  935.     Window w;
  936.     char buffer[30];
  937.  
  938.     if (argc != 3) {
  939.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  940.         " window property\"", (char *) NULL);
  941.     return TCL_ERROR;
  942.     }
  943.  
  944.     w = strtoul(argv[1], &end, 0);
  945.     propName = Tk_InternAtom(main, argv[2]);
  946.     property = NULL;
  947.     result = XGetWindowProperty(Tk_Display(main),
  948.         w, propName, 0, 100000, False, AnyPropertyType,
  949.         &actualType, &actualFormat, (unsigned long *) &length,
  950.         &bytesAfter, (unsigned char **) &property);
  951.     if ((result == Success) && (actualType != None)) {
  952.     if ((actualFormat == 8) && (actualType == XA_STRING)) {
  953.         for (p = property; (p-property) < length; p++) {
  954.         if (*p == 0) {
  955.             *p = '\n';
  956.         }
  957.         }
  958.         Tcl_SetResult(interp, property, TCL_VOLATILE);
  959.     } else {
  960.         for (p = property; length > 0; length--) {
  961.         if (actualFormat == 32) {
  962.             value = *((int *) p);
  963.             p += 4;
  964.         } else if (actualFormat == 16) {
  965.             value = 0xffff & (*((short *) p));
  966.             p += 2;
  967.         } else {
  968.             value = 0xff & *p;
  969.             p += 1;
  970.         }
  971.         sprintf(buffer, "0x%x", value);
  972.         Tcl_AppendElement(interp, buffer);
  973.         }
  974.     }
  975.     }
  976.     if (property != NULL) {
  977.     XFree(property);
  978.     }
  979.     return TCL_OK;
  980. }
  981.  
  982. /*
  983.  *----------------------------------------------------------------------
  984.  *
  985.  * TestsendCmd --
  986.  *
  987.  *    This procedure implements the "testsend" command.  It provides
  988.  *    a set of functions for testing the "send" command and support
  989.  *    procedure in tkSend.c.
  990.  *
  991.  * Results:
  992.  *    A standard Tcl result.
  993.  *
  994.  * Side effects:
  995.  *    Depends on option;  see below.
  996.  *
  997.  *----------------------------------------------------------------------
  998.  */
  999.  
  1000.     /* ARGSUSED */
  1001. static int
  1002. TestsendCmd(clientData, interp, argc, argv)
  1003.     ClientData clientData;        /* Main window for application. */
  1004.     Tcl_Interp *interp;            /* Current interpreter. */
  1005.     int argc;                /* Number of arguments. */
  1006.     char **argv;            /* Argument strings. */
  1007. {
  1008.     TkWindow *winPtr = (TkWindow *) clientData;
  1009.  
  1010.     if (argc < 2) {
  1011.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  1012.         " option ?arg ...?\"", (char *) NULL);
  1013.     return TCL_ERROR;
  1014.     }
  1015.  
  1016. #if !(defined(__WIN32__) || defined(MAC_TCL))
  1017.     if (strcmp(argv[1], "bogus") == 0) {
  1018.     XChangeProperty(winPtr->dispPtr->display,
  1019.         RootWindow(winPtr->dispPtr->display, 0),
  1020.         winPtr->dispPtr->registryProperty, XA_INTEGER, 32,
  1021.         PropModeReplace,
  1022.         (unsigned char *) "This is bogus information", 6);
  1023.     } else if (strcmp(argv[1], "prop") == 0) {
  1024.     int result, actualFormat, length;
  1025.     unsigned long bytesAfter;
  1026.     Atom actualType, propName;
  1027.     char *property, *p, *end;
  1028.     Window w;
  1029.  
  1030.     if ((argc != 4) && (argc != 5)) {
  1031.         Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  1032.             " prop window name ?value ?\"", (char *) NULL);
  1033.         return TCL_ERROR;
  1034.     }
  1035.     if (strcmp(argv[2], "root") == 0) {
  1036.         w = RootWindow(winPtr->dispPtr->display, 0);
  1037.     } else if (strcmp(argv[2], "comm") == 0) {
  1038.         w = Tk_WindowId(winPtr->dispPtr->commTkwin);
  1039.     } else {
  1040.         w = strtoul(argv[2], &end, 0);
  1041.     }
  1042.     propName = Tk_InternAtom((Tk_Window) winPtr, argv[3]);
  1043.     if (argc == 4) {
  1044.         property = NULL;
  1045.         result = XGetWindowProperty(winPtr->dispPtr->display,
  1046.             w, propName, 0, 100000, False, XA_STRING,
  1047.             &actualType, &actualFormat, (unsigned long *) &length,
  1048.             &bytesAfter, (unsigned char **) &property);
  1049.         if ((result == Success) && (actualType != None)
  1050.             && (actualFormat == 8) && (actualType == XA_STRING)) {
  1051.         for (p = property; (p-property) < length; p++) {
  1052.             if (*p == 0) {
  1053.             *p = '\n';
  1054.             }
  1055.         }
  1056.         Tcl_SetResult(interp, property, TCL_VOLATILE);
  1057.         }
  1058.         if (property != NULL) {
  1059.         XFree(property);
  1060.         }
  1061.     } else {
  1062.         if (argv[4][0] == 0) {
  1063.         XDeleteProperty(winPtr->dispPtr->display, w, propName);
  1064.         } else {
  1065.         for (p = argv[4]; *p != 0; p++) {
  1066.             if (*p == '\n') {
  1067.             *p = 0;
  1068.             }
  1069.         }
  1070.         XChangeProperty(winPtr->dispPtr->display,
  1071.             w, propName, XA_STRING, 8, PropModeReplace,
  1072.             (unsigned char *) argv[4], p-argv[4]);
  1073.         }
  1074.     }
  1075.     } else if (strcmp(argv[1], "serial") == 0) {
  1076.     sprintf(interp->result, "%d", tkSendSerial+1);
  1077.     } else {
  1078.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1079.         "\": must be bogus, prop, or serial", (char *) NULL);
  1080.     return TCL_ERROR;
  1081.     }
  1082. #endif
  1083.     return TCL_OK;
  1084. }
  1085.  
  1086. #if !(defined(__WIN32__) || defined(MAC_TCL))
  1087. /*
  1088.  *----------------------------------------------------------------------
  1089.  *
  1090.  * TestwrapperCmd --
  1091.  *
  1092.  *    This procedure implements the "testwrapper" command.  It 
  1093.  *    provides a way from Tcl to determine the extra window Tk adds
  1094.  *    in between the toplevel window and the window decorations.
  1095.  *
  1096.  * Results:
  1097.  *    A standard Tcl result.
  1098.  *
  1099.  * Side effects:
  1100.  *    None.
  1101.  *
  1102.  *----------------------------------------------------------------------
  1103.  */
  1104.  
  1105.     /* ARGSUSED */
  1106. static int
  1107. TestwrapperCmd(clientData, interp, argc, argv)
  1108.     ClientData clientData;        /* Main window for application. */
  1109.     Tcl_Interp *interp;            /* Current interpreter. */
  1110.     int argc;                /* Number of arguments. */
  1111.     char **argv;            /* Argument strings. */
  1112. {
  1113.     TkWindow *winPtr, *wrapperPtr;
  1114.     Tk_Window tkwin;
  1115.  
  1116.     if (argc != 2) {
  1117.     Tcl_AppendResult(interp, "wrong # args;  must be \"", argv[0],
  1118.         " window\"", (char *) NULL);
  1119.     return TCL_ERROR;
  1120.     }
  1121.     
  1122.     tkwin = (Tk_Window) clientData;
  1123.     winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin);
  1124.     if (winPtr == NULL) {
  1125.     return TCL_ERROR;
  1126.     }
  1127.  
  1128.     wrapperPtr = TkpGetWrapperWindow(winPtr);
  1129.     if (wrapperPtr != NULL) {
  1130.     TkpPrintWindowId(interp->result, Tk_WindowId(wrapperPtr));
  1131.     }
  1132.     return TCL_OK;
  1133. }
  1134. #endif
  1135.